home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / lisp / eulisp / comp0_89.lha / Feel / Boot / Compiler / assem.em < prev    next >
Lisp/Scheme  |  1993-04-21  |  4KB  |  144 lines
  1. ;; Eulisp Module
  2. ;; Author: pab
  3. ;; File: assem.em
  4. ;; Date: Sat May  2 14:25:06 1992
  5. ;;
  6. ;; Project:
  7. ;; Description: 
  8. ;;
  9.  
  10. (defmodule assem
  11.   ((except (fold) standard)
  12.    (only (pair) standard0)
  13.    list-fns
  14.   
  15.    instruct
  16.    stream
  17.    comp-defn
  18.  
  19.    stop
  20.    )
  21.   ()
  22.          ;; Assembly....
  23.   ;;
  24.  
  25.   (defun reify-code-list (lst)
  26.     (reify-bytecode-stream lst (make-simple-stream) 0 () ()))
  27.   
  28.   (export reify-code-list)
  29.  
  30.   ;; I assume that input is a list. Really should abstract more 
  31.   ;; so that I can spot, and hack basic blocks, and do micro-optimisation
  32.  
  33.   (defun reify-bytecode-stream (input stream i-count branches lablist)
  34.     (if (null input)
  35.     (progn (format t "Done: ~a instructions~%" i-count)
  36.            (list (convert stream pair) i-count))
  37.       (let ((xx (car input)))
  38.     (labels ((reify-std-instruct (args types branches lablist so-far)
  39.           (cond ((null args)
  40.              (reify-bytecode-stream (cdr input)
  41.                         (write-stream stream 
  42.                                   (cons (i-inumber xx)
  43.                                     (reverse so-far)))
  44.                         (+ i-count (instruction-size xx))
  45.                         branches lablist))
  46.             ((is-branch-arg (car types))
  47.              (let ((i-and-branch (make-branch (car args) branches lablist i-count)))
  48.                (reify-std-instruct (cdr args)
  49.                            (cdr types)
  50.                            (cdr i-and-branch)
  51.                            lablist
  52.                            (cons (car i-and-branch) so-far))))
  53.             (t (let ((ins (reify-arg (car types) (car args) i-count branches lablist)))
  54.                  (reify-std-instruct (cdr args)
  55.                          (cdr types)
  56.                          branches
  57.                          lablist
  58.                          (cons ins so-far))))))
  59.          (add-label (lab)
  60.                 (reify-bytecode-stream (cdr input)
  61.                            stream
  62.                            i-count 
  63.                            (fold (tie-branch i-count lab)
  64.                              branches
  65.                              nil)
  66.                            (cons (cons lab
  67.                                    i-count)
  68.                              lablist))))
  69.         (cond ((is-inline-code xx)
  70.                (reify-bytecode-stream (cdr input) 
  71.                           (write-stream-list stream 
  72.                                  (inline-code xx))
  73.                           (+ (inline-code-count xx) i-count)
  74.                           branches 
  75.                           lablist))
  76.               ((is-null-op xx)
  77.                (reify-bytecode-stream (cdr input) stream i-count branches lablist))
  78.               ((is-label xx)
  79.                (add-label (instruction-label xx)))
  80.               (t 
  81.                (reify-std-instruct (i-arg-list xx)
  82.                        (instruction-argtypes (i-info xx))
  83.                        branches
  84.                        lablist
  85.                        nil)))))))
  86.  
  87.   (defun reify-arg (argtype arg i-count branches labels)
  88.     ;; returns list  converted arg + new branch info
  89.     (cond
  90.      ((is-link-arg argtype)
  91.       (make-link arg))
  92.      ((is-static-arg argtype) 
  93.       (if (consp arg)
  94.       arg
  95.     (make-static arg)))
  96.      ((= argtype 4);; XXX
  97.       (if (consp arg)
  98.       arg
  99.     (list (the-long-handle) arg)))
  100.      (t arg)))
  101.  
  102.   ;; convert a branch into something sane.
  103.   ;; returns cons of instruction, plus branches
  104.  
  105.   (defun make-branch (label branches labels i-count)
  106.     (let ((xx (find-label label labels)))
  107.       (if (null xx)
  108.       (let ((bytes (list (the-long-handle) label)))
  109.         (cons bytes 
  110.           (cons (cons (cdr bytes) i-count)
  111.             branches)))
  112.     ;; found the label
  113.     (cons (list (the-long-handle)
  114.             (- (cdr xx) i-count))
  115.           branches))))
  116.  
  117.   (defun find-label (lab lst)
  118.     ;; Labels ought to be unique.
  119.     (assoc lab lst eq))
  120.  
  121.   (defun make-link (arg)
  122.     (cons (the-link-handle) arg))
  123.  
  124.   (defun make-static (arg)
  125.     (cons (the-static-handle) arg))
  126.  
  127.   ;; enclosing fold ought to be destructive...
  128.   (defun tie-branch (i-count lab)
  129.     (lambda (branch left)
  130.       (if (eq (caar branch) lab)
  131.       (progn ;;(format t "setting cadr:~a~%" branch)
  132.          ((setter car) (car branch)
  133.           (- i-count (cdr branch)))
  134.          left)
  135.     (cons branch left))))
  136.  
  137.   (defun instruction-size (x)
  138.     ;; may be a prob with null instructions...
  139.     (fold + (instruction-argwidth (i-info x)) 1))
  140.  
  141.  
  142.   ;; end module
  143.   )
  144.